home *** CD-ROM | disk | FTP | other *** search
/ Meeting Pearls 4 / Meeting Pearls Vol. IV (1996)(GTI - Schatztruhe)[!].iso / Pearls / dev / Oberon / OberonV4 / system / OPL.Mod (.txt) < prev    next >
Oberon Text  |  1996-05-10  |  47KB  |  1,320 lines
  1. Syntax10.Scn.Fnt
  2. Syntax10b.Scn.Fnt
  3. Syntax10i.Scn.Fnt
  4. MODULE OPL;
  5. (* Code emitter for MC68020.
  6.  Diplomarbeit Samuel Urech
  7.  Date: 04.11.92   Current version: 23.2.93
  8.  changes in red and blue by Ralf Degner 22.5.1995
  9.  020 specific code: Trapcc and many more
  10.  IMPORT OPT, OPM, SYSTEM;
  11.  CONST
  12.   NewLabel* = 0;
  13.   (* item modes *)
  14.   dreg = 0; areg = 1; freg = 2; postinc = 3; predec = 4; regx = 5; abs = 7; imm = 8; immL = 9; pcx = 10; coc = 12; fcoc = 13;
  15.   (* object modes *)
  16.   Var = 1; VarPar = 2; Con = 3; Fld = 4; Typ = 5; LProc = 6; XProc = 7;
  17.   SProc = 8; CProc = 9; IProc = 10; Mod = 11; Head = 12; TProc = 13;
  18.   (* module visibility of objects *)
  19.   internal = 0; external = 1; externalR = 2;
  20.   (* instruction formats *)
  21.   noext = 0; briefext = 1; fullext = 2; wordDispl = 3; longDispl = 4; extern = 5;
  22.   (* sizes *)
  23.   byte = 0; word = 1; long = 2;
  24.   CP =  0F200H; (* Coprocessor word *)
  25.   DIVS = 81C0H; DIVU = 80C0H; MULS = 0C1C0H; MULU = 0C0C0H;
  26.   (* Condition Codes *)
  27.   CC = 4; CS = 5; EQ = 7; false = 1; GE = 12; GT = 14; HI = 2; LE = 15;
  28.   LS = 3; LT = 13; MI = 11; NE = 6; PL = 10; true = 0; VC = 8; VS = 9;
  29.   (* Floating Point Condition Codes *)
  30.   FEQ = 1; FNE = 0EH; FGT = 12H; FNGT = 1DH; FGE = 13H; FNGE = 1CH; FLT = 14H; FNLT = 1BH; FLE = 15H;
  31.   FNLE = 1AH; Ffalse = 0; Ftrue = 0FH;
  32.   (* Floating Point Control Registers *)
  33.   FPCR = 4; FPSR = 2; FPIAR = 1;
  34.   (* structure forms *)
  35.   Undef = 0; Byte = 1; Bool = 2; Char = 3; SInt = 4; Int = 5; LInt = 6;
  36.   Real = 7; LReal = 8; Set = 9; String = 10; NilTyp = 11; NoTyp = 12;
  37.   Pointer = 13; ProcTyp = 14; Comp = 15;
  38.   (* composite structure forms *)
  39.   Basic = 1; Array = 2; DynArr = 3; Record = 4;
  40.   IntSet = { SInt .. LInt };
  41.   RealSet = { Real, LReal };
  42.   ByteSet = { SInt, Byte, Char, Bool };
  43.   WordSet = { Int };
  44.   LongSet = { LInt, Set, Pointer, ProcTyp };
  45.   None = -1; (* no index or offset register *)
  46.   (* Implementation restrictions *)
  47.   CodeLength = 65535; (* code size in bytes *)
  48.   ConstSize* = 10000; (* constant size *)
  49.   MaxEntry* = 256; (* maximum number of entries *)
  50.   MaxPtrs = 256; (* maximum number of global pointers, old 128 *)
  51.   MaxComs = 60; (* maximum number of commands, old 40 *)
  52.   MaxExts* = 7; (* maximum number of extensions of a record type *)
  53.   (* Offsets in type descriptor *)
  54.   BaseTypeOffs* = 40;
  55.   PtrTabOffs = BaseTypeOffs + 4 * ( MaxExts + 1 );
  56.   MethodOffs* = -4;
  57.  TYPE Label* = LONGINT;
  58.    Item* = RECORD
  59.     mode* : INTEGER; (* dreg, areg, freg, postinc, predec, regx, abs, imm, immL, pcx, coc, fcoc *)
  60.     typ* : OPT.Struct;
  61.     reg* : INTEGER; (* D0 .. D7: 0 .. 7, A0 .. A7: 8 .. 15, FP0 .. FP7: 16 .. 23 *)
  62.     bd* : LONGINT;
  63.     inxReg* : INTEGER; (* None = -1, D0 .. D7: 0 .. 7 *)
  64.     xsize* : INTEGER; (* word: 0; long: 1 *)
  65.     scale* : INTEGER; (* 0, 1, 2, 3 for sizes 1, 2, 4, 8 bytes *)
  66.     tJump*, fJump* : Label; (* for coc- and fcoc-items only *)
  67.     offsReg* : INTEGER; (* for multidimensional dynamic arrays only *)
  68.     nolen* : INTEGER; (* pointer to dynamic array: number of lengths; string: length; 0 otherwise *)
  69.    END; (* Item *)
  70. (* Items:
  71. mode       |  bd          reg     inxReg     xsize     scale    tJump    fJump
  72. ------------------------------------------------------------------------------
  73. dreg       |              reg                                                  (0 .. 7)
  74. areg       |              reg                                                  (8 .. 15)
  75. freg       |              reg                                                  (16 .. 23)
  76. postinc    |              reg
  77. predec     |              reg
  78. regx       |  bd          reg     inxReg     xsize     scale
  79. abs        |  mno/eno
  80. imm, immL  |  val
  81. pcx        |  bd                  inxReg     xsize     scale
  82. coc        |  t/fcond                                           tJump    fJump
  83. fcoc       |  t/fcond                                           tJump    fJump
  84.  VAR code : ARRAY CodeLength OF CHAR; (* generated code *)
  85.    constant : ARRAY ConstSize OF SYSTEM.BYTE; (* constants *)
  86.    entry* : ARRAY MaxEntry OF LONGINT; (* displacements of the exported objects or type descriptor address *)
  87.    pc* : LONGINT;
  88.    link* : INTEGER; (* root of fixup chain *)
  89.    entno* : INTEGER; (* number of exported objects *)
  90.    conx : LONGINT; (* index to the constant array *)
  91.    nofrec : INTEGER; (* number of type descriptors *)
  92.    dsize* : LONGINT; (* size of the global variables *)
  93.    level* : SHORTINT; (* nesting level *)
  94.    usedRegs* : SET; (* used registers: data registers: 0..7, address registers: 8..15, floating point registers: 16..23 *)
  95.    LastSubBegin, LastSubEnd, SubWert : LONGINT;
  96.  PROCEDURE Init*( opt : SET );
  97.  BEGIN (* Init *)
  98.   pc := 0;
  99.   entno := 1; (* for module entry *)
  100.   conx := ConstSize;
  101.   nofrec := 0;
  102.   dsize := 0;
  103.   level := 0;
  104.   usedRegs := {};
  105.   link := 0
  106.  END Init;
  107.  PROCEDURE BegStat*;
  108.  (* Frees all registers. Should be called at the beginning of a statement. *)
  109.  BEGIN (* BegStat *)
  110.   usedRegs := { }
  111.  END BegStat;
  112.  PROCEDURE PutByte( x : LONGINT );
  113.  (* Writes a byte to the code and increments the PC. *)
  114.  BEGIN (* PutByte *)
  115.   IF pc >= CodeLength THEN
  116.    OPM.err( 210 )
  117.   ELSE
  118.    code[ pc ] := CHR( x );
  119.    INC( pc )
  120.   END; (* IF *)
  121.  END PutByte;
  122.  PROCEDURE PutWord( x : LONGINT );
  123.  (* Writes a word to the code and increments the PC by 2. *)
  124.  BEGIN
  125.   PutByte( x DIV 100H );
  126.   PutByte( x MOD 100H )
  127.  END PutWord;
  128.  PROCEDURE PutLongWord( x : LONGINT );
  129.  (* Writes a longword to the code and increments the PC by 4. *)
  130.  BEGIN
  131.   PutWord( x DIV 10000H );
  132.   PutWord( x MOD 10000H )
  133.  END PutLongWord;
  134.  PROCEDURE ConstWord*( pos : INTEGER; val : LONGINT );
  135.  (* Puts the word val at position pos into the constant area. *)
  136.  BEGIN (* ConstWord *)
  137.   constant[ pos ] := CHR( val DIV 100H );
  138.   constant[ pos + 1 ] := CHR( val )
  139.  END ConstWord;
  140.  PROCEDURE PatchWord( pos, val : LONGINT );
  141.  (* Patches the value val at position pos in the code. *)
  142.  BEGIN (* PatchWord *)
  143.   code[ pos ] := CHR( val DIV 100H );
  144.   code[ pos + 1 ] := CHR( val )
  145.  END PatchWord;
  146.  PROCEDURE SetEntry*( pos : INTEGER; val : LONGINT );
  147.  (* Sets entry[ pos ] to the given value. *)
  148.  BEGIN (* SetEntry *)
  149.   entry[ pos ] := val
  150.  END SetEntry;
  151.  PROCEDURE DispSize( disp : LONGINT ) : INTEGER;
  152.  (* Returns a code for the size of a displacement. This code is used in the extension word.
  153.    0         --> 1
  154.    16 Bit --> 2
  155.    32 Bit --> 3 *)
  156.  BEGIN (* DispSize *)
  157.   IF disp = 0 THEN RETURN 1
  158.   ELSIF ( disp >= MIN( INTEGER ) ) & ( disp <= MAX( INTEGER ) ) THEN RETURN 2
  159.   ELSE RETURN 3
  160.   END
  161.  END DispSize;
  162.  PROCEDURE Trapcc*( condition, trapnr : INTEGER );
  163.  (* Writes the code for TRAPcc. *)
  164.  BEGIN (* Trapcc *)
  165.   PutWord( 50FAH + SYSTEM.LSH( condition, 8 ) );
  166.   PutWord( trapnr )
  167.  END Trapcc;
  168.  PROCEDURE LengthCode( size : LONGINT ) : INTEGER;
  169.  (* Returns the size code that is used in the instruction. *)
  170.  BEGIN (* LengthCode *)
  171.   CASE size OF
  172.    1 : RETURN byte
  173.    | 2 : RETURN word
  174.    | 4 : RETURN long
  175.   END; (* CASE *)
  176.  END LengthCode;
  177.  PROCEDURE FloatFormat( typ : OPT.Struct ) : INTEGER;
  178.  (* Returns the code that is filled into the source specifier field of a floating point instruction. *)
  179.  BEGIN (* FloatFormat *)
  180.   IF typ.form IN ByteSet THEN RETURN 6
  181.   ELSIF typ.form IN WordSet THEN RETURN 4
  182.   ELSIF typ.form IN LongSet THEN RETURN 0
  183.   ELSIF typ = OPT.realtyp THEN RETURN 1
  184.   ELSIF typ = OPT.lrltyp THEN RETURN 5
  185.   ELSE HALT( 96 )
  186.   END; (* IF *)
  187.  END FloatFormat;
  188.  PROCEDURE Scale*( size : LONGINT ) : INTEGER;
  189.  (* Returns the code for the scale factor of a size. *)
  190.  BEGIN (* Scale *)
  191.   CASE size OF
  192.    1 : RETURN 0
  193.    | 2 : RETURN 1
  194.    | 4 : RETURN 2
  195.    | 8 : RETURN 3
  196.   END; (* CASE *)
  197.  END Scale;
  198.  PROCEDURE FindPtrs*( typ : OPT.Struct; adr : LONGINT; VAR ptrTab : ARRAY OF LONGINT; VAR nofptrs : INTEGER );
  199.  (* Appends the pointer addresses to ptrTab that occur in the given type. nofptrs is incremented accordingly. *)
  200.   VAR fld: OPT.Object;
  201.     btyp : OPT.Struct;
  202.     i, n, s : LONGINT;
  203.  BEGIN (* FindPtrs *)
  204.   IF typ.form = Pointer THEN
  205.    IF nofptrs < LEN( ptrTab ) THEN
  206.        ptrTab[ nofptrs ] := adr
  207.    ELSE
  208.        OPM.Mark(222, 0); nofptrs:=0
  209.    END;
  210.    INC( nofptrs )
  211.   ELSIF typ.comp = Record THEN
  212.    btyp := typ.BaseTyp;
  213.    IF btyp # NIL THEN FindPtrs( btyp, adr, ptrTab, nofptrs ) END;
  214.    fld := typ.link;
  215.    WHILE ( fld # NIL ) & ( fld.mode = Fld ) DO
  216.     IF fld.name # OPM.HdPtrName THEN
  217.      FindPtrs( fld.typ, fld.adr + adr, ptrTab, nofptrs )
  218.     ELSE
  219.      IF nofptrs < LEN( ptrTab ) THEN
  220.          ptrTab[ nofptrs ] := fld.adr + adr
  221.     ELSE
  222.         OPM.Mark(222, 0); nofptrs:=0
  223.     END;
  224.      INC( nofptrs )
  225.     END; (* IF *)
  226.     fld := fld.link
  227.    END; (* IF *)
  228.   ELSIF typ.comp = Array THEN
  229.    btyp := typ.BaseTyp;
  230.    n := typ.n;
  231.    WHILE btyp.comp = Array DO n := btyp.n * n; btyp := btyp.BaseTyp END;
  232.    IF ( btyp.form = Pointer ) OR ( btyp.comp = Record ) THEN
  233.     i := 0; s := btyp.size;
  234.     WHILE i < n DO FindPtrs( btyp, i * s + adr, ptrTab, nofptrs ); INC( i ) END
  235.    END; (* IF *)
  236.   ELSIF typ.comp = DynArr THEN
  237.    FindPtrs( typ.BaseTyp, 0, ptrTab, nofptrs )
  238.   END; (* IF *)
  239.  END FindPtrs;
  240.  PROCEDURE MakeTypDesc( typ : OPT.Struct; offset : LONGINT; VAR typdesc : ARRAY OF CHAR; VAR pos : LONGINT );
  241.  (* Generates a type descriptor. *)
  242.   VAR
  243.     i: INTEGER;
  244.     j: LONGINT;
  245.     nofptrs : INTEGER;
  246.     baseTyp : OPT.Struct;
  247.     tProcTab : ARRAY MaxEntry OF OPT.Object;
  248.     ptrTab : ARRAY 1000 OF LONGINT;
  249.   PROCEDURE FindTProcs( typ : OPT.Struct );
  250.   (* Writes all methods of the given type into tProcTab. *)
  251.    PROCEDURE trav( obj : OPT.Object );
  252.    BEGIN
  253.     IF obj # NIL THEN
  254.      IF obj.mode = TProc THEN tProcTab[ obj.adr DIV 10000H ] := obj END;
  255.      trav(obj.left);
  256.      trav(obj.right)
  257.     END
  258.    END trav;
  259.   BEGIN (* FindTProcs *)
  260.    IF typ.BaseTyp # NIL THEN FindTProcs( typ.BaseTyp ) END;
  261.    trav( typ.link )
  262.   END FindTProcs;
  263.   PROCEDURE SetByte( pos, val : INTEGER );
  264.   (* Sets the byte at offset pos in the type descriptor to value val. *)
  265.   BEGIN (* SetByte *)
  266.    typdesc[ pos + offset ] := CHR( val )
  267.   END SetByte;
  268.   PROCEDURE SetWord( pos, val : INTEGER );
  269.   (* Sets the word at offset pos in the type descriptor to value val. *)
  270.   BEGIN (* SetWord *)
  271.    typdesc[ pos + offset ] := CHR( val DIV 100H );
  272.    typdesc[ pos + offset + 1 ] := CHR( val MOD 100H )
  273.   END SetWord;
  274.   PROCEDURE SetLong( pos : INTEGER; val : LONGINT );
  275.   (* Sets the longword at offset pos in the type descriptor to value val. *)
  276.   BEGIN (* SetLong *)
  277.    SetWord( pos, SHORT( val DIV 10000H ) );
  278.    SetWord( pos + 2, SHORT( val MOD 10000H ) )
  279.   END SetLong;
  280.   PROCEDURE Set24( pos : INTEGER; VAR name : ARRAY OF CHAR );
  281.   (* Sets the next 24 Bytes at offset pos in the type descriptor to name. *)
  282.    VAR i : INTEGER;
  283.   BEGIN (* Set24 *)
  284.    i := 0;
  285.    WHILE ( i < 24 ) & ( i < LEN( name ) ) DO
  286.     typdesc[ pos + offset + i ] := name[ i ];
  287.     INC( i )
  288.    END; (* WHILE *)
  289.   END Set24;
  290.  BEGIN (* MakeTypDesc *)
  291.   FOR j := 0 TO LEN( typdesc ) - 1 DO typdesc[ j ] := 0X END;
  292.   SetLong( 0, typ.size );
  293.   SetWord( 4, typ.extlev );
  294.   SetWord( 6, SHORT( typ.n ) );
  295.   IF typ.strobj # NIL THEN
  296.    Set24( 16, typ.strobj.name )
  297.   END; (* IF *)
  298.   SetByte( BaseTypeOffs + 4 * typ.extlev + 2, typ.mno );
  299.   SetByte( BaseTypeOffs + 4 * typ.extlev + 3, entno );
  300.   baseTyp := typ.BaseTyp;
  301.   WHILE baseTyp # NIL DO
  302.    SetByte( BaseTypeOffs + 4 * baseTyp.extlev + 2, baseTyp.mno );
  303.    SetByte( BaseTypeOffs + 4 * baseTyp.extlev + 3, SHORT( baseTyp.tdadr ) );
  304.    baseTyp := baseTyp.BaseTyp
  305.   END; (* WHILE *)
  306.   nofptrs := 0;
  307.   FindPtrs( typ, 0, ptrTab, nofptrs );
  308.   FOR i := 0 TO nofptrs - 1 DO SetLong( PtrTabOffs + 4 * i, ptrTab[ i ] ) END;
  309.   SetLong( PtrTabOffs + 4 * nofptrs, -( PtrTabOffs + 4 * nofptrs ) );
  310.   FindTProcs( typ );
  311.   FOR i := 0 TO SHORT(typ.n) - 1 DO
  312.    SetByte( MethodOffs - 4 * ( i + 1 ) + 2, -tProcTab[ i ].mnolev );
  313.    SetByte( MethodOffs - 4 * ( i + 1 ) + 3, SHORT( tProcTab[ i ].adr MOD 100H ) )
  314.   END; (* FOR *)
  315.   pos := PtrTabOffs + 4 * nofptrs + 4
  316.  END MakeTypDesc;
  317.  PROCEDURE AllocBytes*( VAR s : ARRAY OF SYSTEM.BYTE; len : LONGINT; VAR adr : LONGINT );
  318.  (* Allocates s of length len in the constant area with alignment on 8 bytes. adr returns the new address. *)
  319.   VAR align : LONGINT;
  320.  BEGIN (* AllocBytes *)
  321.   align := ( -len ) MOD 8;
  322.   WHILE ( align > 0 ) & ( conx > 0 ) DO
  323.    DEC( conx );
  324.    constant[ conx ] := 0X;
  325.    DEC( align )
  326.   END; (* WHILE *)
  327.   WHILE ( len > 0 ) & ( conx > 0 ) DO
  328.    DEC( conx );
  329.    DEC( len );
  330.    constant[ conx ] := s[ len ]
  331.   END; (* WHILE *)
  332.   adr := conx;
  333.   IF len > 0 THEN
  334.    OPM.err( 230 )
  335.   END; (* IF *)
  336.  END AllocBytes;
  337.  PROCEDURE AllocTypDesc*( typ : OPT.Struct );
  338.  (* Allocates a type descriptor in the constant area. *)
  339.   VAR typdesc : ARRAY 1000 OF CHAR;
  340.     adr, pos, neg : LONGINT;
  341.  BEGIN (* AllocTypDesc *)
  342.   IF ( typ.comp = Record ) & ( typ.tdadr = OPM.TDAdrUndef ) THEN
  343.    neg := -MethodOffs + 4 * typ.n;
  344.    INC( neg, ( -neg ) MOD 8 );
  345.    MakeTypDesc( typ, neg, typdesc, pos );
  346.    INC( pos, ( -pos ) MOD 8 ); (* alignment to 8 because of the Garbage Collector *)
  347.    AllocBytes( typdesc, pos + neg, adr );
  348.    SetEntry( entno, adr - ConstSize - dsize + neg );
  349.    typ.tdadr := entno;
  350.    INC( entno );
  351.    IF typ.extlev > MaxExts THEN OPM.err( 233 )
  352.    ELSE INC( nofrec )
  353.    END; (* IF *)
  354.   END; (* IF *)
  355.  END AllocTypDesc;
  356.  PROCEDURE AllocConst*( obj : OPT.Object; typ : OPT.Struct; VAR bytes : ARRAY OF SYSTEM.BYTE; len : LONGINT;
  357.            VAR item : Item );
  358.  (* Allocates a constant in the constant area if necessary and returns an item describing it. *)
  359.   VAR adr : LONGINT;
  360.  BEGIN (* AllocConst *)
  361.   IF obj = NIL THEN (* no name constant *)
  362.    AllocBytes( bytes, len, adr );
  363.    item.mode := pcx;
  364.    item.inxReg := None;
  365.    item.bd := adr - ConstSize - dsize
  366.   ELSIF obj.conval.intval = OPM.ConstNotAlloc THEN (* named constant not yet allocated *)
  367.    AllocBytes( bytes, len, adr );
  368.    item.mode := pcx;
  369.    item.inxReg := None;
  370.    item.bd := adr - ConstSize - dsize;
  371.    obj.conval.intval := item.bd
  372.   ELSE (* named allocated constant *)
  373.    item.mode := pcx;
  374.    item.inxReg := None;
  375.    item.bd := obj.conval.intval
  376.   END; (* IF *)
  377.   item.typ := typ
  378.  END AllocConst;
  379.  PROCEDURE DefineLabel*( VAR label : Label );
  380.  (* Defines a label and solves its fixup chain if necessary. *)
  381.   VAR next : Label;
  382.     disp : LONGINT;
  383.  BEGIN (* DefineLabel *)
  384.   IF label > 0 THEN HALT( 97 ) END;
  385.   LastSubEnd:=0;
  386.   label := -label;
  387.   WHILE label # NewLabel DO (* solve fixup chain *)
  388.    next := 2 * ( 100H * LONG( ORD( code[ label ] ) ) + LONG( ORD( code[ label + 1 ] ) ) );
  389.    disp := pc - label;
  390.    IF ( disp < MIN( INTEGER ) ) OR ( disp > MAX( INTEGER ) ) THEN
  391.     OPM.err( 211 )
  392.    END;
  393.    PatchWord( label, disp );
  394.    label := next
  395.   END; (* WHILE *)
  396.   label := pc
  397.  END DefineLabel;
  398.  PROCEDURE MergedLinks*( l0, l1 : Label ) : Label;
  399.  (* Merges the fixup chains of the two labels. *)
  400.   VAR cur, next : Label;
  401.  BEGIN (* MergedLinks *)
  402.   IF l0 < 0 THEN
  403.    cur := -l0;
  404.    LOOP
  405.     next := 2 * ( 100H * LONG( ORD( code[ cur ] ) ) + LONG( ORD( code[ cur + 1 ] ) ) );
  406.     IF next = NewLabel THEN EXIT END;
  407.     cur := next
  408.    END; (* LOOP *)
  409.    PatchWord( cur, -l1 DIV 2 );
  410.    RETURN l0
  411.   ELSE RETURN l1
  412.   END; (* IF *)
  413.  END MergedLinks;
  414.  PROCEDURE Jump*( condition : INTEGER; VAR label : Label );
  415.  (* Generates code for a conditional branch to the given label. If the label is not yet defined, the fixup chain is appended. *)
  416.   VAR disp : LONGINT;
  417.  BEGIN (* Jump *)
  418.   IF label > 0 THEN (* label defined*)
  419.    disp := label - pc - 2;
  420.    IF ( disp >= MIN( SHORTINT ) ) & ( disp < MAX( SHORTINT ) ) THEN
  421.     IF disp < 0 THEN INC( disp, 256 ) END;
  422.     PutWord( 6000H + SYSTEM.LSH( condition, 8 ) + disp )
  423.    ELSIF ( disp >= MIN( INTEGER ) ) & ( disp < MAX( INTEGER ) ) THEN
  424.     PutWord( 6000H + SYSTEM.LSH( condition, 8 ) );
  425.     PutWord( disp )
  426.    ELSE
  427.     OPM.err( 211 )
  428.    END; (* IF *)
  429.   ELSE (* label undefined, append fixup chain *)
  430.    PutWord( 6000H + SYSTEM.LSH( condition, 8 ) );
  431.    PutWord( -label DIV 2 );
  432.    label := -( pc - 2 )
  433.   END; (* IF *)
  434.  END Jump;
  435.  PROCEDURE FJump*( condition : INTEGER; VAR label : Label );
  436.  (* Generates code for a conditional branch to the given label. The condition is a floating point condition.
  437.   If the label is not yet defined, the fixup chain is appended. *)
  438.  (* something went wrong with backjumps => problems with REPEAT UNTIL FloadCond *)
  439.   VAR disp : LONGINT;
  440.  BEGIN (* FJump *)
  441.   PutWord( CP + 80H + condition );
  442.   IF label > 0 THEN (* label defined *)
  443.    disp := label - pc - 2 + 2;
  444.    IF DispSize( disp ) = 2 THEN
  445.     PutWord( disp )
  446.    ELSE
  447.     OPM.err( 211 )
  448.    END; (* IF *)
  449.   ELSE (* label undefined, append fixup chain *)
  450.    PutWord( -label DIV 2 );
  451.    label := -( pc - 2 )
  452.   END; (* IF *)
  453.  END FJump;
  454.  PROCEDURE Bsr*( VAR label : Label );
  455.  (* Writes the code for a subroutine call to the given label. If the label is not yet defined, the fixup chain is appended. *)
  456.   VAR disp : LONGINT;
  457.  BEGIN (* Bsr *)
  458.   IF label > 0 THEN (* label defined *)
  459.    disp := label - pc - 2;
  460.    IF ( disp >= MIN( SHORTINT ) ) & ( disp <= MAX( SHORTINT ) ) THEN
  461.     IF disp < 0 THEN INC( disp, 256 ) END;
  462.     PutWord( 6100H + disp )
  463.    ELSIF DispSize( disp ) = 2 (* word *) THEN
  464.     PutWord( 6100H );
  465.     PutWord( disp )
  466.    ELSE (* long *)
  467.     PutWord( 61FFH );
  468.     PutLongWord( disp )
  469.    END; (* IF *)
  470.   ELSE (* label undefined, append fixup chain *)
  471.    PutWord( 6100H );
  472.    PutWord( -label DIV 2 );
  473.    label := -( pc - 2 )
  474.   END; (* IF *)
  475.  END Bsr;
  476.  PROCEDURE Encode( VAR item : Item; VAR mode, reg, extWord, format : INTEGER; VAR bd : LONGINT; offset : INTEGER );
  477.  (* Returns mode, register, extension word and format of an item.
  478.   The following values have to be written to the code:
  479.    format = noext: mode, reg
  480.    format = briefext: mode, reg, extWord
  481.    format = fullext: mode, reg, extWord, bd (if # 0)
  482.    format = wordDispl, longDispl, extern: mode, reg, bd *)
  483.  BEGIN (* Encode *)
  484.   bd := item.bd;
  485.   CASE item.mode OF
  486.    dreg : mode := 0; reg := item.reg; format := noext
  487.    | areg : mode := 1; reg := item.reg - 8; format := noext
  488.    | freg : mode := 0; reg := 0; format := noext
  489.    | postinc : mode := 3; reg := item.reg - 8; format := noext
  490.    | predec : mode := 4; reg := item.reg - 8; format := noext
  491.    | regx :
  492.     IF item.inxReg = None THEN
  493.      CASE DispSize( bd ) OF
  494.       1 :
  495.        mode := 2;
  496.        format := noext
  497.       | 2 :
  498.        mode := 5;
  499.        format := wordDispl
  500.       | 3 :
  501.        mode := 6;
  502.        extWord := 170H;
  503.        format := fullext
  504.      END; (* CASE *)
  505.     ELSE
  506.      mode := 6;
  507.      IF ( bd >= MIN( SHORTINT ) ) & ( bd <= MAX( SHORTINT ) ) THEN
  508.       IF bd < 0 THEN INC( bd, 100H ) END;
  509.       extWord := SYSTEM.LSH( item.inxReg, 12 ) + SYSTEM.LSH( item.xsize, 11 ) + SYSTEM.LSH( item.scale, 9 ) +
  510.            SHORT( bd );
  511.       format := briefext
  512.      ELSE
  513.       extWord := SYSTEM.LSH( item.inxReg, 12 ) + SYSTEM.LSH( item.xsize, 11 ) + SYSTEM.LSH( item.scale, 9 ) +
  514.            SYSTEM.LSH( DispSize( bd ), 4 ) + 100H;
  515.       format := fullext
  516.      END; (* IF *)
  517.     END; (* IF *)
  518.     reg := item.reg - 8
  519.    | abs :
  520.     mode := 7;
  521.     reg := 1;
  522.     format := extern
  523.    | imm :
  524.     mode := 7;
  525.     reg := 4;
  526.     IF item.typ.size = 4 THEN
  527.      format := longDispl
  528.     ELSE
  529.      format := wordDispl
  530.     END; (* IF *)
  531.    | immL :
  532.     mode := 7;
  533.     reg := 4;
  534.     format := extern
  535.    | pcx :
  536.     DEC( bd, pc + offset );
  537.     mode := 7;
  538.     IF item.inxReg = None THEN
  539.      IF DispSize( bd ) < 3 THEN
  540.       reg := 2;
  541.       format := wordDispl
  542.      ELSE
  543.       reg := 3;
  544.       format := fullext;
  545.       extWord := 170H
  546.      END; (* IF *)
  547.     ELSE
  548.      reg := 3;
  549.      IF ( bd >= MIN( SHORTINT ) ) & ( bd <= MAX( SHORTINT ) ) THEN
  550.       IF bd < 0 THEN INC( bd, 100H ) END;
  551.       extWord := SYSTEM.LSH( item.inxReg, 12 ) + SYSTEM.LSH( item.xsize, 11 ) +
  552.            SYSTEM.LSH( item.scale, 9 ) + SHORT( bd );
  553.       format := briefext
  554.      ELSE
  555.       extWord := SYSTEM.LSH( item.inxReg, 12 ) + SYSTEM.LSH( item.xsize, 11 ) +
  556.            SYSTEM.LSH( item.scale, 9 ) + SYSTEM.LSH( DispSize( bd ), 4 ) + 100H;
  557.       format := fullext
  558.      END; (* IF *)
  559.     END; (* IF *)
  560.   END; (* CASE *)
  561.  END Encode;
  562.  PROCEDURE PutExtension( format, extWord : INTEGER; bd : LONGINT );
  563.  (* Writes extensions to the code according to the given format. *)
  564.   VAR val : LONGINT;
  565.  BEGIN (* PutExtension *)
  566.   CASE format OF
  567.    noext : (* nothing *)
  568.    | briefext : PutWord( extWord )
  569.    | fullext :
  570.     PutWord( extWord );
  571.     CASE DispSize( bd ) OF
  572.      1 : (* nothing *)
  573.      | 2 : PutWord( bd )
  574.      | 3 : PutLongWord( bd )
  575.     END
  576.    | wordDispl :
  577.     PutWord( bd )
  578.    | longDispl :
  579.     PutLongWord( bd )
  580.    | extern : (* this was an external reference; link chain has to be appended *)
  581.     val := SYSTEM.LSH( LONG( link ), 16 ) + bd;
  582.     link := SHORT( pc DIV 2 );
  583.     PutLongWord( val )
  584.   END; (* CASE *)
  585.  END PutExtension;
  586.  PROCEDURE GetReg*( ) : INTEGER;
  587.  (* Returns the next free data register. *)
  588.   VAR i : INTEGER;
  589.  BEGIN (* GetReg *)
  590.   i := 0;
  591.   WHILE ( i < 8 ) & ( i IN usedRegs ) DO INC( i ) END;
  592.   IF i = 8 THEN
  593.    OPM.err( 215 )
  594.   END;
  595.   INCL( usedRegs, i );
  596.   RETURN i
  597.  END GetReg;
  598.  PROCEDURE GetAdrReg*( ) : INTEGER;
  599.  (* Returns the next free address register. A6 and A7 are not returned. *)
  600.   VAR i,j : INTEGER;
  601.  BEGIN (* GetAdrReg *)
  602.   i:=8;
  603.   WHILE ( i < 14 ) & ( i IN usedRegs ) DO INC( i ) END;
  604.   IF i = 14 THEN
  605.    OPM.err( 215 )
  606.   END;
  607.   INCL( usedRegs, i );
  608.   RETURN i
  609.  END GetAdrReg;
  610.  PROCEDURE GetFReg*( ) : INTEGER;
  611.  (* Returns the next free floating point register. FP7 is reserved for code procedures. *)
  612.   VAR i : INTEGER;
  613.  BEGIN (* GetFReg *)
  614.   i := 16;
  615.   WHILE ( i < 23 ) & ( i IN usedRegs ) DO INC( i ) END;
  616.   IF i = 23 THEN
  617.    OPM.err( 216 )
  618.   END;
  619.   INCL( usedRegs, i );
  620.   RETURN i
  621.  END GetFReg;
  622.  PROCEDURE FreeReg*( VAR item : Item );
  623.  (* Frees all registers that are used by the item. The item must be defined before and is undefined afterwards. *)
  624.  BEGIN (* FreeReg *)
  625.   IF item.mode IN { dreg, areg, freg, postinc, predec, regx } THEN
  626.    EXCL( usedRegs, item.reg )
  627.   END; (* IF *)
  628.   IF ( item.inxReg # None ) & ( item.mode IN { regx, pcx } ) THEN
  629.    EXCL( usedRegs, item.inxReg )
  630.   END; (* IF *)
  631.  END FreeReg;
  632.  PROCEDURE Lea*( VAR source : Item; destReg : INTEGER );
  633.  (* Writes the code for LEA. *)
  634.   VAR mode, reg, extWord, format : INTEGER;
  635.     bd : LONGINT;
  636.  BEGIN (* Lea *)
  637.   Encode( source, mode, reg, extWord, format, bd, 2 );
  638.   PutWord( 41C0H + SYSTEM.LSH( destReg - 8, 9 ) + SYSTEM.LSH( mode, 3 ) + reg );
  639.   PutExtension( format, extWord, bd )
  640.  END Lea;
  641.  PROCEDURE LoadAdr*( VAR item : Item );
  642.  (* If the item is pc-relative, its address is loaded into an address register. *)
  643.   VAR reg : INTEGER;
  644.  BEGIN (* LoadAdr *)
  645.   IF item.mode = pcx THEN
  646.    reg := GetAdrReg( );
  647.    Lea( item, reg );
  648.    item.mode := regx;
  649.    item.reg := reg;
  650.    item.bd := 0;
  651.    item.inxReg := None;
  652.    item.offsReg := None
  653.   END; (* IF *)
  654.  END LoadAdr;
  655.  PROCEDURE LoadExternal*( VAR item : Item );
  656.  (* If the item is an external reference, its address is loaded into an address register and a regx item is returned. *)
  657.   VAR reg : INTEGER;
  658.  BEGIN (* LoadExternal *)
  659.   IF item.mode = abs THEN
  660.    reg := GetAdrReg( );
  661.    Lea( item, reg );
  662.    item.mode := regx;
  663.    item.reg := reg;
  664.    item.bd := 0;
  665.    item.inxReg := None;
  666.    item.offsReg := None
  667.   END; (* IF *)
  668.  END LoadExternal;
  669.  PROCEDURE Format7*( opcode : LONGINT; VAR dest : Item );
  670.  (* CLR, NEG, NEGX, NOT, TST *)
  671.   VAR mode, reg, extWord, format : INTEGER;
  672.     bd : LONGINT;
  673.  BEGIN (* Format7 *)
  674.   Encode( dest, mode, reg, extWord, format, bd, 0 );
  675.   PutWord( 4000H + SYSTEM.LSH( opcode, 8 ) + SYSTEM.LSH( LengthCode( dest.typ.size ), 6 ) +
  676.      SYSTEM.LSH( mode, 3 ) + reg );
  677.   PutExtension( format, extWord, bd )
  678.  END Format7;
  679.  PROCEDURE Moveq*( val : INTEGER; reg : INTEGER );
  680.  (* Writes the code for MOVEQ.L #val, Dreg *)
  681.  BEGIN (* Moveq *)
  682.   IF val < 0 THEN INC( val, 256 ) END;
  683.   PutWord( 7000H + SYSTEM.LSH( reg, 9 ) + val )
  684.  END Moveq;
  685.  PROCEDURE Move*( VAR source, dest : Item );
  686.  (* Writes the code for MOVE source, dest. Instruction size is source.typ.size. *)
  687.  (* move #0,?? >> clr ?? *)
  688.  (* move.l #b,d? (-127<=b<=127 >> Moveq *)
  689.   VAR sourceMode, sourceReg, sourceExtWord, sourceFormat,
  690.     destMode, destReg, destExtWord, destFormat,
  691.     sizeCode : INTEGER;
  692.     sourcebd, destbd : LONGINT;
  693.  BEGIN (* Move *)
  694.   IF (source.mode=imm) & (source.bd=0) & (~(dest.mode=pcx)) THEN
  695.    Format7(2, dest); (* clr dest *)
  696.   ELSIF (source.mode=imm) & (dest.mode=dreg) & (source.typ.size=4) & (dest.bd<128) & (dest.bd>-128) & (~(dest.mode=pcx)) THEN
  697.    Moveq(SHORT(source.bd), dest.reg)
  698.   ELSE
  699.    CASE LengthCode( source.typ.size ) OF
  700.     byte : sizeCode := 1
  701.     | word : sizeCode := 3
  702.     | long : sizeCode := 2
  703.    END; (* CASE *)
  704.    Encode( dest, destMode, destReg, destExtWord, destFormat, destbd, 0 );
  705.    Encode( source, sourceMode, sourceReg, sourceExtWord, sourceFormat, sourcebd, 2 );
  706.    PutWord( SYSTEM.LSH( sizeCode, 12 ) + SYSTEM.LSH( destReg, 9 ) + SYSTEM.LSH( destMode, 6 ) +
  707.        SYSTEM.LSH( sourceMode, 3 ) + sourceReg );
  708.    PutExtension( sourceFormat, sourceExtWord, sourcebd );
  709.    PutExtension( destFormat, destExtWord, destbd )
  710.   END
  711.  END Move;
  712.  PROCEDURE Movem*( dir, regList : INTEGER; VAR item : Item );
  713.  (* Writes the code for MOVEM.L *)
  714.   VAR mode, reg, extWord, format : INTEGER;
  715.     bd : LONGINT;
  716.  BEGIN (* Movem *)
  717.   Encode( item, mode, reg, extWord, format, bd, 0 );
  718.   PutWord( 48C0H + SYSTEM.LSH( dir, 10 ) + SYSTEM.LSH( mode, 3 ) + reg );
  719.   PutWord( regList );
  720.   PutExtension( format, extWord, bd )
  721.  END Movem;
  722.  PROCEDURE FMove*( VAR source, dest : Item );
  723.  (* Writes the code for FMOVE.size source, dest. Packed Decimal Real is not supported. *)
  724.  (* move from FPReg to FPReg only knows .X and has its own command, real strange bug *)
  725.   VAR mode, reg, extWord, format : INTEGER;
  726.     bd : LONGINT;
  727.  BEGIN (* FMove *)
  728.   IF dest.mode = freg THEN
  729.    IF source.mode = freg THEN
  730.     PutWord( CP);
  731.     PutWord(SYSTEM.LSH(source.reg-16, 10) + SYSTEM.LSH(dest.reg-16, 7))
  732.    ELSE
  733.     Encode( source, mode, reg, extWord, format, bd, 4 );
  734.     PutWord( CP + SYSTEM.LSH( mode, 3 ) + reg );
  735.     PutWord( 4000H + SYSTEM.LSH( FloatFormat( source.typ ), 10 ) + SYSTEM.LSH( dest.reg - 16, 7 ) );
  736.     PutExtension( format, extWord,  bd )
  737.    END
  738.   ELSIF source.mode = freg THEN
  739.    Encode( dest, mode, reg, extWord, format, bd, 0 );
  740.    PutWord( CP + SYSTEM.LSH( mode, 3 ) + reg );
  741.    PutWord( 6000H + SYSTEM.LSH( FloatFormat( source.typ ), 10 ) + SYSTEM.LSH( source.reg - 16, 7 ) );
  742.    PutExtension( format, extWord, bd )
  743.   ELSE
  744.    HALT( 95 )
  745.   END; (* IF *)
  746.  END FMove;
  747.  PROCEDURE FMovecr*( VAR item : Item; dr, controlReg : INTEGER );
  748.  (* Writes the code for FMOVE von oder nach einem Control Register. *)
  749.   VAR mode, reg, extWord, format : INTEGER;
  750.     bd : LONGINT;
  751.  BEGIN (* FMovecr *)
  752.   Encode( item, mode, reg, extWord, format, bd, 4 );
  753.   PutWord( CP + SYSTEM.LSH( mode, 3 ) + reg );
  754.   PutWord( 8000H + SYSTEM.LSH( dr, 13 ) + SYSTEM.LSH( controlReg, 10 ) );
  755.   PutExtension( format, extWord, bd )
  756.  END FMovecr;
  757.  PROCEDURE FMovem*( dir, regList : INTEGER; VAR item : Item );
  758.  (* Writes the code for FMOVEM.X. For (SP)+ and -(SP) only! *)
  759.   VAR mode, reg, extWord, format : INTEGER;
  760.     bd : LONGINT;
  761.  BEGIN (* FMovem *)
  762.   Encode( item, mode, reg, extWord, format, bd, 0 );
  763.   PutWord( CP + SYSTEM.LSH( mode, 3 ) + reg );
  764.   PutWord( 0C000H + SYSTEM.LSH( 1 - dir, 13 ) + SYSTEM.LSH( dir, 12 ) + regList );
  765.   (* without PutExtension! *)
  766.  END FMovem;
  767.  PROCEDURE Load*( VAR item : Item );
  768.  (* Loads the item into a data register. *)
  769.   VAR source : Item;
  770.  BEGIN (* Load *)
  771.   IF item.mode # dreg THEN
  772.    source := item;
  773.    item.mode := dreg;
  774.    item.reg := GetReg( );
  775.    IF source.mode = freg THEN
  776.     FMove( source, item )
  777.    ELSE
  778.     Move( source, item )
  779.    END; (* IF *)
  780.   END; (* IF *)
  781.  END Load;
  782.  PROCEDURE FLoad*( VAR item : Item );
  783.  (* Loads the item into a floating point register. *)
  784.   VAR regItem : Item;
  785.  BEGIN (* FLoad *)
  786.   IF item.mode # freg THEN
  787.    regItem.mode := freg;
  788.    regItem.typ := item.typ;
  789.    regItem.reg := GetFReg( );
  790.    FMove( item, regItem );
  791.    item := regItem
  792.   END; (* IF *)
  793.  END FLoad;
  794.  PROCEDURE AssertDestReg*( typ : OPT.Struct; VAR source, dest : Item );
  795.  (* Makes sure that dest is a register, either by swapping the items or by loading dest. *)
  796.   VAR swap : Item;
  797.  BEGIN (* AssertDestReg *)
  798.   IF ( typ = OPT.realtyp ) OR ( typ = OPT.lrltyp ) THEN
  799.    IF dest.mode # freg THEN
  800.     IF source.mode = freg THEN
  801.      swap := dest;
  802.      dest := source;
  803.      source := swap
  804.     ELSE
  805.      FLoad( dest )
  806.     END; (* IF *)
  807.    END; (* IF *)
  808.   ELSE
  809.    IF dest.mode # dreg THEN
  810.     IF source.mode = dreg THEN
  811.      swap := dest;
  812.      dest := source;
  813.      source := swap
  814.     ELSE
  815.      Load( dest )
  816.     END; (* IF *)
  817.    END; (* IF *)
  818.   END; (* IF *)
  819.  END AssertDestReg;
  820.  PROCEDURE TFConds*( tcond : LONGINT ) : LONGINT;
  821.  (* Converts a condition code to true- and false-conditions. *)
  822.   VAR fcond : INTEGER;
  823.  BEGIN (* TFConds *)
  824.   CASE tcond OF
  825.    CC : fcond := CS
  826.    | CS : fcond := CC
  827.    | EQ : fcond := NE
  828.    | NE : fcond := EQ
  829.    | false : fcond := true
  830.    | true : fcond := false
  831.    | GE : fcond := LT
  832.    | LT : fcond := GE
  833.    | GT : fcond := LE
  834.    | LE : fcond := GT
  835.    | HI : fcond := LS
  836.    | LS : fcond := HI
  837.    | MI : fcond := PL
  838.    | PL : fcond := MI
  839.    | VC : fcond := VS
  840.    | VS : fcond := VC
  841.   END; (* CASE *)
  842.   RETURN 10000H * tcond + fcond
  843.  END TFConds;
  844.  PROCEDURE TFFConds*( tcond : LONGINT ) : LONGINT;
  845.  (* Converts a floating point condition code to true- and false-conditions. *)
  846.   VAR fcond : INTEGER;
  847.  BEGIN (* TFFConds *)
  848.   CASE tcond OF
  849.    FEQ : fcond := FNE
  850.    | FNE : fcond := FEQ
  851.    | FGE : fcond := FNGE
  852.    | FLT : fcond := FNLT
  853.    | FGT : fcond := FNGT
  854.    | FLE : fcond := FNLE
  855.   END; (* CASE *)
  856.   RETURN 10000H * tcond + fcond
  857.  END TFFConds;
  858.  PROCEDURE Chk*( VAR item, chkItem : Item );
  859.  (* Writes the code for CHK. *)
  860.  (* move ??,dx chk dx,dy changed to chk ??,dy *)
  861.   VAR mode, reg, extWord, format, size : INTEGER;
  862.     bd : LONGINT;
  863.  BEGIN (* Chk *)
  864.   IF item.typ = OPT.linttyp THEN
  865.    size := 0
  866.   ELSE
  867.    size := 1
  868.   END;
  869.   Load( item );
  870.   (* Load( chkItem ); *)
  871.   Encode( chkItem, mode, reg, extWord, format, bd, 2 );
  872.   PutWord( 4100H + SYSTEM.LSH( item.reg, 9 ) + SYSTEM.LSH( size, 7 ) + SYSTEM.LSH( mode, 3 ) + reg );
  873.   PutExtension( format, extWord, bd )
  874.  END Chk;
  875.  PROCEDURE DBcc*( condition : INTEGER; VAR reg : INTEGER; VAR label : Label );
  876.  (* Writes the code for DBcc. label must be defined. *)
  877.  BEGIN (* DBcc *)
  878.   PutWord( 50C8H + SYSTEM.LSH( condition, 8 ) + reg );
  879.   PutWord( label - pc )
  880.  END DBcc;
  881.  PROCEDURE Ext*( VAR reg : Item; destSize : INTEGER );
  882.  (* Writes the code for EXT and EXTB. destSize is the desired length code.*)
  883.  BEGIN (* Ext *)
  884.   Load( reg );
  885.   IF reg.typ.size = 1 THEN
  886.    IF destSize = word THEN
  887.     PutWord( 4880H + reg.reg )
  888.    ELSE (* long *)
  889.     PutWord( 49C0H + reg.reg )
  890.    END
  891.   ELSIF reg.typ.size = 2 THEN
  892.    PutWord( 48C0H + reg.reg )
  893.   END; (* IF *)
  894.  END Ext;
  895.  PROCEDURE Divsl*( VAR source, remainder, quotient : Item );
  896.  (* Writes the code for DIVSL.L source, remainder:quotient. *)
  897.   VAR mode, reg, extWord, format : INTEGER;
  898.     bd : LONGINT;
  899.  BEGIN (* Divsl *)
  900.   Load( remainder );
  901.   Load( quotient );
  902.   Encode( source, mode, reg, extWord, format, bd, 4 );
  903.   PutWord( 4C40H + SYSTEM.LSH( mode, 3 ) + reg );
  904.   PutWord( 800H + SYSTEM.LSH( quotient.reg, 12 ) + remainder.reg );
  905.   PutExtension( format, extWord, bd )
  906.  END Divsl;
  907.  PROCEDURE Swap*( VAR dest : Item );
  908.  (* Writes the code for SWAP. *)
  909.  BEGIN (* Swap *)
  910.   Load( dest );
  911.   PutWord( 4840H + dest.reg )
  912.  END Swap;
  913.  PROCEDURE Eor*( VAR source, dest : Item );
  914.  (* Writes the code for EOR source, dest. *)
  915.   VAR mode, reg, extWord, format : INTEGER;
  916.     bd : LONGINT;
  917.  BEGIN (* Eor *)
  918.   Load( source );
  919.   Encode( dest, mode, reg, extWord, format, bd, 0 );
  920.   PutWord( 0B100H + SYSTEM.LSH( source.reg, 9 ) + SYSTEM.LSH( LengthCode( dest.typ.size ), 6 ) +
  921.       SYSTEM.LSH( mode, 3 ) + reg );
  922.   PutExtension( format, extWord, bd )
  923.  END Eor;
  924.  PROCEDURE Enter*( val : LONGINT );
  925.  (* Writes the code for procedure or module entry. *)
  926.  BEGIN
  927.   IF DispSize( val ) = 3 THEN
  928.    PutWord( 480EH );
  929.    PutLongWord( val )
  930.   ELSE
  931.    PutWord( 4E56H );
  932.    PutWord( val )
  933.   END; (* IF *)
  934.  END Enter;
  935.  PROCEDURE Return*;
  936.  (* Writes the code for procedure or module exit. *)
  937.  BEGIN
  938.   PutWord( 4E5EH ); (* UNLK A6 *)
  939.   PutWord( 4E75H ); (* RTS *)
  940.  END Return;
  941.  PROCEDURE WriteCProc*( code : OPT.ConstExt );
  942.  (* Writes the code of a code procedure. *)
  943.   VAR i, n : INTEGER;
  944.  BEGIN (* WriteCProc *)
  945.   n := ORD( code^[ 0 ] );
  946.   FOR i := 1 TO n DO PutByte( ORD( code^[ i ] ) ) END
  947.  END WriteCProc;
  948.  PROCEDURE Format1*( opcode : LONGINT; data : INTEGER; VAR dest : Item );
  949.  (* ADDQ, SUBQ *)
  950.   VAR mode, reg, extWord, format : INTEGER;
  951.     bd : LONGINT;
  952.  BEGIN (* Format1 *)
  953.   Encode( dest, mode, reg, extWord, format, bd, 0 );
  954.   IF data = 8 THEN data := 0 END;
  955.   PutWord( 5000H + SYSTEM.LSH( data, 9 ) + SYSTEM.LSH( opcode, 8 ) + SYSTEM.LSH( LengthCode( dest.typ.size ), 6 ) +
  956.       SYSTEM.LSH( mode, 3 ) + reg );
  957.   PutExtension( format, extWord, bd )
  958.  END Format1;
  959.  PROCEDURE Format6*( opcode : LONGINT; data : LONGINT; VAR dest : Item );
  960.  (* ADDI, ANDI, CMPI, EORI, ORI, SUBI *)
  961.   VAR size, mode, reg, extWord, format : INTEGER;
  962.     bd : LONGINT;
  963.  BEGIN (* Format6 *)
  964.   size := LengthCode( dest.typ.size );
  965.   Encode( dest, mode, reg, extWord, format, bd, 0 );
  966.   PutWord( SYSTEM.LSH( opcode, 8 ) + SYSTEM.LSH( size, 6 ) + SYSTEM.LSH( mode, 3 ) + reg );
  967.   IF size = long THEN
  968.    PutLongWord( data )
  969.   ELSE
  970.    PutWord( data )
  971.   END; (* IF *)
  972.   PutExtension( format, extWord, bd )
  973.  END Format6;
  974.  PROCEDURE Format2*( opcode : LONGINT; VAR source, dest : Item );
  975.  (* ADD, AND, OR, SUB *)
  976.   VAR mode, reg, extWord, format, size : INTEGER;
  977.     bd : LONGINT;
  978.  BEGIN (* Format2 *)
  979.   size := LengthCode( source.typ.size );
  980.   IF dest.mode = dreg THEN
  981.    Encode( source, mode, reg, extWord, format, bd, 2 );
  982.    PutWord( SYSTEM.LSH( opcode, 12 ) + SYSTEM.LSH( dest.reg, 9 ) + SYSTEM.LSH( size, 6 ) + SYSTEM.LSH( mode, 3 ) + reg );
  983.    PutExtension( format, extWord, bd )
  984.   ELSE
  985.    Load( source );
  986.    Encode( dest, mode, reg, extWord, format, bd, 0 );
  987.    PutWord( 100H + SYSTEM.LSH( opcode, 12 ) + SYSTEM.LSH( source.reg, 9 ) + SYSTEM.LSH( size, 6 ) +
  988.        SYSTEM.LSH( mode, 3 ) + reg );
  989.    PutExtension( format, extWord, bd )
  990.   END; (* IF *)
  991.  END Format2;
  992.  PROCEDURE Format3*( opcode : LONGINT; VAR source : Item; destReg : INTEGER );
  993.  (* ADDA, SUBA *)
  994.  (* uses ADDQ/SUBQ if possible *)
  995.  (* try to collect ADDA #x,A7 and SUBA #y,A7 *)
  996.   VAR mode, reg, extWord, format, size : INTEGER;
  997.     bd : LONGINT;
  998.     dest: Item;
  999.     ImmFlag: BOOLEAN;
  1000.  BEGIN (* Format3 *)
  1001.   ImmFlag:=FALSE;
  1002.   IF (source.mode=imm) & (destReg=8+7) THEN
  1003.    ImmFlag:=TRUE;
  1004.    IF (LastSubEnd=pc) THEN
  1005.     pc:=LastSubBegin;
  1006.     IF opcode=13 THEN
  1007.      INC(SubWert, source.bd)
  1008.     ELSE
  1009.      DEC(SubWert, source.bd)
  1010.     END;
  1011.     IF SubWert>0 THEN
  1012.      source.bd:=SubWert;opcode:=13
  1013.     ELSE
  1014.      source.bd:=-SubWert;opcode:=9
  1015.     END
  1016.    ELSE
  1017.     IF opcode=13 THEN
  1018.      SubWert:=source.bd
  1019.     ELSE
  1020.      SubWert:=-source.bd
  1021.     END
  1022.    END;
  1023.    LastSubBegin:=pc
  1024.   END;
  1025.   IF (source.mode=imm) & (~(dest.mode=pcx)) & (source.bd>0) & (source.bd<=16) THEN
  1026.    dest.mode:=areg;dest.reg:=destReg;dest.inxReg:=-1;NEW(dest.typ);dest.typ.size:=source.typ.size;
  1027.    IF (opcode=13) THEN opcode:=0 ELSE opcode:=1 END;
  1028.    IF source.bd>8 THEN
  1029.     Format1(opcode, 8, dest);
  1030.     DEC(source.bd, 8)
  1031.    END;
  1032.    Format1(opcode, SHORT(source.bd), dest)
  1033.   ELSIF ~((source.mode=imm) & (source.bd=0)) THEN
  1034.    IF LengthCode( source.typ.size ) = long THEN
  1035.     size := 1
  1036.    ELSE
  1037.     size := 0
  1038.    END; (* IF *)
  1039.    Encode( source, mode, reg, extWord, format, bd, 2 );
  1040.    PutWord( 0C0H + SYSTEM.LSH( opcode, 12 ) + SYSTEM.LSH( destReg - 8, 9 )+ SYSTEM.LSH( size, 8 ) +
  1041.        SYSTEM.LSH( mode, 3 ) + reg );
  1042.    PutExtension( format, extWord, bd )
  1043.   END;
  1044.   IF ImmFlag THEN
  1045.    LastSubEnd:=pc
  1046.   END
  1047.  END Format3;
  1048.  PROCEDURE Format4*( opcode : LONGINT; bitnr : LONGINT; VAR dest : Item );
  1049.  (* BSET, BCLR, BCHG, BTST, static bit number. *)
  1050.   VAR mode, reg, extWord, format : INTEGER;
  1051.     bd : LONGINT;
  1052.  BEGIN (* Format4 *)
  1053.   Load( dest );
  1054.   Encode( dest, mode, reg, extWord, format, bd, 0 );
  1055.   PutWord( 0800H + SYSTEM.LSH( opcode, 6 ) + SYSTEM.LSH( mode, 3 ) + reg );
  1056.   PutWord( bitnr );
  1057.   PutExtension( format, extWord, bd )
  1058.  END Format4;
  1059.  PROCEDURE Format5*( opcode : LONGINT; VAR bitnr, dest : Item );
  1060.  (* BSET, BCLR, BCHG, BTST, dynamic bit number. *)
  1061.   VAR mode, reg, extWord, format : INTEGER;
  1062.     bd : LONGINT;
  1063.  BEGIN (* Format5 *)
  1064.   Load( bitnr );
  1065.   Load( dest );
  1066.   Encode( dest, mode, reg, extWord, format, bd, 0 );
  1067.   PutWord( 0100H + SYSTEM.LSH( bitnr.reg, 9 ) + SYSTEM.LSH( opcode, 6 ) + SYSTEM.LSH( mode, 3 ) + reg );
  1068.   PutExtension( format, extWord, bd )
  1069.  END Format5;
  1070.  PROCEDURE Format8*( opcode : LONGINT; VAR source, dest : Item );
  1071.  (* Coprocessor operation. *)
  1072.   VAR mode, reg, extWord, format : INTEGER;
  1073.     bd : LONGINT;
  1074.  BEGIN (* Format8 *)
  1075.   FLoad( dest );
  1076.   IF source.mode = freg THEN
  1077.    PutWord( CP );
  1078.    PutWord( SYSTEM.LSH( source.reg - 16, 10 ) + SYSTEM.LSH( dest.reg - 16, 7 ) + opcode )
  1079.   ELSE
  1080.    Encode( source, mode, reg, extWord, format, bd, 4 );
  1081.    PutWord( CP + SYSTEM.LSH( mode, 3 ) + reg );
  1082.    PutWord( 4000H + SYSTEM.LSH( FloatFormat( source.typ ), 10 ) + SYSTEM.LSH( dest.reg - 16, 7 ) + opcode );
  1083.    PutExtension( format, extWord, bd )
  1084.   END; (* IF *)
  1085.  END Format8;
  1086. (* I think, Format9 and Format 10 are never used => no bitfields *)
  1087.  PROCEDURE Format9*( opcode : LONGINT; VAR dest : Item; offset, width : INTEGER );
  1088.  (* BFCHG, BFCLR, BFSET, BFTST, static offset and width. *)
  1089.   VAR mode, reg, extWord, format : INTEGER;
  1090.     bd : LONGINT;
  1091.  BEGIN (* Format9 *)
  1092.   Load( dest );
  1093.   IF width > 0 THEN
  1094.    IF width = 32 THEN width := 0 END;
  1095.    Encode( dest, mode, reg, extWord, format, bd, 0 );
  1096.    PutWord( 0E0C0H + SYSTEM.LSH( opcode, 8 ) + SYSTEM.LSH( mode, 3 ) + reg );
  1097.    PutWord( SYSTEM.LSH( offset, 6 ) + width );
  1098.    PutExtension( format, extWord, bd )
  1099.   END; (* IF *)
  1100.  END Format9;
  1101.  PROCEDURE Format10*( opcode : LONGINT; offset : INTEGER; VAR width, dest : Item );
  1102.  (* BFCHG, BFCLR, BFSET, BFTST, static offset, dynamic width. *)
  1103.   VAR mode, reg, extWord, format : INTEGER;
  1104.     bd : LONGINT;
  1105.  BEGIN (* Format10 *)
  1106.   Load( width );
  1107.   Load( dest );
  1108.   Encode( dest, mode, reg, extWord, format, bd, 0 );
  1109.   PutWord( 0E0C0H + SYSTEM.LSH( opcode, 8 ) + SYSTEM.LSH( mode, 3 ) + reg );
  1110.   PutWord( 20H + SYSTEM.LSH( offset, 6 ) + width.reg );
  1111.   PutExtension( format, extWord, bd )
  1112.  END Format10;
  1113.  PROCEDURE Format11*( opcode : LONGINT; VAR source, dest : Item );
  1114.  (* MULU, MULS, DIVU, DIVS (short form) *)
  1115.   VAR mode, reg, extWord, format : INTEGER;
  1116.     bd : LONGINT;
  1117.  BEGIN (* Format11 *)
  1118.   Load( dest );
  1119.   Encode( source, mode, reg, extWord, format, bd, 2 );
  1120.   PutWord( opcode + SYSTEM.LSH( dest.reg, 9 ) + SYSTEM.LSH( mode, 3 ) + reg );
  1121.   PutExtension( format, extWord, bd )
  1122.  END Format11;
  1123.  PROCEDURE Format12*( opcode : LONGINT; VAR source, dest : Item );
  1124.  (* MULU, MULS, DIVU, DIVS (long form with one result register) *)
  1125.   VAR mode, reg, extWord, format, bit6, bit11 : INTEGER;
  1126.     bd : LONGINT;
  1127.  BEGIN (* Format12 *)
  1128.   IF opcode = MULU THEN bit6 := 0; bit11 := 0
  1129.   ELSIF opcode = MULS THEN bit6 := 0; bit11 := 1
  1130.   ELSIF opcode = DIVU THEN bit6 := 1; bit11 := 0
  1131.   ELSIF opcode = DIVS THEN bit6 := 1; bit11 := 1
  1132.   END; (* IF *)
  1133.   Load( dest );
  1134.   Encode( source, mode, reg, extWord, format, bd, 4 );
  1135.   PutWord( 4C00H + SYSTEM.LSH( bit6, 6 ) + SYSTEM.LSH( mode, 3 ) + reg );
  1136.   PutWord( SYSTEM.LSH( dest.reg, 12 ) + SYSTEM.LSH( bit11, 11 ) + dest.reg );
  1137.   PutExtension( format, extWord, bd )
  1138.  END Format12;
  1139.  PROCEDURE Format13*( opcode, shiftleft : INTEGER; VAR dest : Item );
  1140.  (* ASL, ASR, LSL, LSR, ROL, ROR, ROXL, ROXR, static number of bits. *)
  1141.   VAR dr, size : INTEGER;
  1142.  BEGIN (* Format13 *)
  1143.   size := LengthCode( dest.typ.size );
  1144.   IF shiftleft > 0 THEN dr := 1 ELSE dr := 0 END;
  1145.   IF ABS( shiftleft ) = 8 THEN shiftleft := 0 END;
  1146.   Load( dest );
  1147.   PutWord( 0E000H + SYSTEM.LSH( ABS( shiftleft ), 9 ) + SYSTEM.LSH( dr, 8 ) + SYSTEM.LSH( size, 6 )
  1148.        + SYSTEM.LSH( opcode, 3 ) + dest.reg )
  1149.  END Format13;
  1150.  PROCEDURE Format14*( opcode, dr : INTEGER; VAR shift, dest : Item );
  1151.  (* ASL, ASR, LSL, LSR, ROL, ROR, ROXL, ROXR, dynamic number of bits. *)
  1152.  BEGIN (* Format14 *)
  1153.   Load( shift );
  1154.   Load( dest );
  1155.   PutWord( 0E020H + SYSTEM.LSH( shift.reg, 9 ) + SYSTEM.LSH( dr, 8 ) + SYSTEM.LSH( LengthCode( dest.typ.size ), 6 )
  1156.       + SYSTEM.LSH( opcode, 3 ) + dest.reg )
  1157.  END Format14;
  1158.  PROCEDURE Format15*( opcode : INTEGER; VAR item : Item );
  1159.  (* JMP, JSR, PEA *)
  1160.   VAR mode, reg, extWord, format : INTEGER;
  1161.     bd : LONGINT;
  1162.  BEGIN (* Format15 *)
  1163.   Encode( item, mode, reg, extWord, format, bd, 2 );
  1164.   PutWord( 4000H + SYSTEM.LSH( opcode, 6 ) + SYSTEM.LSH( mode, 3 ) + reg );
  1165.   PutExtension( format, extWord, bd )
  1166.  END Format15;
  1167.  PROCEDURE Cmp*( VAR source, dest : Item );
  1168.  (* Writes the code for CMP source, dest. *)
  1169.  (* cmp #a,?? >> cmpi #a,?? or tst ?? if a=0 *)
  1170.   VAR mode, reg, extWord, format, size : INTEGER;
  1171.     bd : LONGINT;
  1172.  BEGIN (* Cmp *)
  1173.   size:= LengthCode( source.typ.size );
  1174.   IF (source.mode=imm) & (source.bd=0) & (~(dest.mode=pcx)) THEN (* TST *)
  1175.          (*Encode( dest, mode, reg, extWord, format, bd, 2 );
  1176.          PutWord( 4A00H + SYSTEM.LSH( size, 6 ) + SYSTEM.LSH( mode, 3 ) + reg );*)
  1177.    Format7(10, dest)
  1178.   ELSIF (source.mode=imm) & (~(dest.mode=pcx)) THEN (* CMPI *)
  1179.          (*Encode( dest, mode, reg, extWord, format, bd, 6 );
  1180.          PutWord(  0C00H + SYSTEM.LSH( size, 6 ) + SYSTEM.LSH( mode, 3 ) + reg );
  1181.          IF size = long THEN
  1182.           PutLongWord( source.bd )
  1183.          ELSIF size = word THEN
  1184.           PutWord( source.bd )
  1185.          ELSE
  1186.           PutByte( 0);PutByte( source.bd)
  1187.          END; (* IF *)*)
  1188.    Format6(12, source.bd, dest)
  1189.   ELSE
  1190.    Load(dest);
  1191.    Encode( source, mode, reg, extWord, format, bd, 2 );
  1192.    PutWord( 0B000H + SYSTEM.LSH( dest.reg, 9 ) + SYSTEM.LSH( size, 6 ) +
  1193.        SYSTEM.LSH( mode, 3 ) + reg );
  1194.    PutExtension( format, extWord, bd )
  1195.   END
  1196.  END Cmp;
  1197.  PROCEDURE OutRefPoint*;
  1198.  BEGIN (* OutRefPoint *)
  1199.   OPM.RefW( 0F8X );
  1200.   OPM.RefWInt( pc )
  1201.  END OutRefPoint;
  1202.  PROCEDURE OutRefName*( name : ARRAY OF CHAR );
  1203.  (* Writes a name to the reference file. *)
  1204.   VAR ch : CHAR;
  1205.     i : INTEGER;
  1206.  BEGIN (* OutRefName *)
  1207.   i := 0;
  1208.   REPEAT
  1209.    ch := name[ i ];
  1210.    OPM.RefW( ch );
  1211.    INC( i )
  1212.   UNTIL ch = 0X
  1213.  END OutRefName;
  1214.  PROCEDURE OutRefs*( obj : OPT.Object );
  1215.  (* Writes the reference information of the variables. *)
  1216.   VAR f : INTEGER;
  1217.  BEGIN (* OutRefs *)
  1218.   IF obj # NIL THEN
  1219.    OutRefs( obj^.left );
  1220.    IF ( obj^.mode = Var ) OR ( obj^.mode = VarPar ) THEN
  1221.     f := obj^.typ^.form;
  1222.     IF ( f IN { Byte .. Set, Pointer } ) OR ( obj^.typ^.comp = Array ) & ( obj^.typ^.BaseTyp^.form = Char ) THEN
  1223.      IF obj^.mode = Var THEN OPM.RefW( 1X ) ELSE OPM.RefW( 3X ) END;
  1224.      IF obj^.typ^.comp = Array THEN OPM.RefW( 0FX )
  1225.      ELSE OPM.RefW( CHR( f ) )
  1226.      END;
  1227.      OPM.RefWInt( obj^.linkadr );
  1228.      OutRefName( obj^.name )
  1229.     END
  1230.    END;
  1231.    OutRefs(obj^.right)
  1232.   END
  1233.  END OutRefs;
  1234.  PROCEDURE WriteName( VAR name : ARRAY OF CHAR; n : INTEGER );
  1235.  (* Writes name to the object file with at least n characters. *)
  1236.   VAR i : INTEGER; ch : CHAR;
  1237.  BEGIN
  1238.   i := 0;
  1239.   REPEAT
  1240.    ch := name[ i ];
  1241.    OPM.ObjW( ch );
  1242.    INC( i )
  1243.   UNTIL ch = 0X;
  1244.   WHILE i < n DO OPM.ObjW( 0X ); INC( i ) END
  1245.  END WriteName;
  1246.  PROCEDURE OutCode*( VAR modName : ARRAY OF CHAR; key : LONGINT );
  1247.  (* Writes the object file. *)
  1248.   VAR i : LONGINT;
  1249.     nofcom, nofptrs : INTEGER;
  1250.     obj : OPT.Object;
  1251.     comTab : ARRAY MaxComs OF OPT.Object;
  1252.     ptrTab : ARRAY MaxPtrs OF LONGINT;
  1253.   PROCEDURE Traverse( obj : OPT.Object );
  1254.   (* Collects commands in comTab and global pointers in ptrTab. Increments nofcom and nofptrs accordingly. *)
  1255.   BEGIN (* Traverse *)
  1256.    IF obj # NIL THEN
  1257.     IF obj.mode = XProc THEN
  1258.      IF ( obj.vis # internal ) & ( obj.link = NIL ) & ( obj.typ = OPT.notyp ) THEN (* command *)
  1259.       IF nofcom < MaxComs THEN
  1260.        comTab[ nofcom ] := obj;
  1261.        INC(nofcom)
  1262.       ELSE
  1263.        OPM.Mark(232, 0);
  1264.        nofcom := 0
  1265.       END; (* IF *)
  1266.      END; (* IF *)
  1267.     ELSIF ( obj.mode = Var ) & ( obj.linkadr < 0 ) THEN
  1268.      FindPtrs( obj.typ, obj.linkadr, ptrTab, nofptrs )
  1269.     END; (* IF *)
  1270.     Traverse( obj.left );
  1271.     Traverse( obj.right )
  1272.    END; (* IF *)
  1273.   END Traverse;
  1274.  BEGIN (* OutCode *)
  1275.   nofcom := 0;
  1276.   nofptrs := 0;
  1277.   Traverse( OPT.topScope.right );
  1278.  (* header block *)
  1279.   OPM.ObjWInt( entno );
  1280.   OPM.ObjWInt( nofcom );
  1281.   OPM.ObjWInt( nofptrs );
  1282.   OPM.ObjWInt( OPT.nofGmod );
  1283.   OPM.ObjWInt( link );
  1284.   OPM.ObjWLInt( dsize );
  1285.   OPM.ObjWLInt( ConstSize - conx );
  1286.   OPM.ObjWLInt( pc );
  1287.   OPM.ObjWLInt( key );
  1288.   WriteName( modName, 24 );
  1289.  (* entry block *)
  1290.   OPM.ObjW( 82X );
  1291.   FOR i := 0 TO entno - 1 DO OPM.ObjWLInt( entry[ i ] ) END;
  1292.  (* command block *)
  1293.   OPM.ObjW( 83X );
  1294.   FOR i := 0 TO nofcom - 1 DO
  1295.    obj := comTab[ i ];
  1296.    WriteName( obj.name, 0 );
  1297.    OPM.ObjWLInt( entry[ obj.adr ] )
  1298.   END; (* FOR *)
  1299.  (* pointer block *)
  1300.   OPM.ObjW( 84X );
  1301.   FOR i := 0 TO nofptrs - 1 DO OPM.ObjWLInt( ptrTab[ i ] ) END;
  1302.  (* import block *)
  1303.   OPM.ObjW( 85X );
  1304.   FOR i := 0 TO OPT.nofGmod - 1 DO
  1305.    obj := OPT.GlbMod[ i ];
  1306.    OPM.ObjWLInt( obj.adr );
  1307.    WriteName( obj.name, 0 )
  1308.   END; (* FOR *)
  1309.  (* data block *)
  1310.   OPM.ObjW( 86X );
  1311.   FOR i := conx TO ConstSize - 1 DO OPM.ObjW( SYSTEM.VAL( CHAR, constant[ i ] ) ) END;
  1312.  (* code block *)
  1313.   OPM.ObjW( 87X );
  1314.   OPM.ObjWBytes( code, pc );
  1315.  (* ref block written in OPM.CloseRefObj *)
  1316.  END OutCode;
  1317.  PROCEDURE Close*;
  1318.  END Close;
  1319. END OPL.
  1320.